gusucode.com > 耐品图片管理系统 标准版A > 耐品图片管理系统 标准版A/Admin_UploadFile.asp
<!--#include file="Admin_ChkPurview1.asp"-->
<!--#include FILE="Inc/UploadClass.asp"-->
<!--#include file="Inc/clsImage.asp"-->
<html>
<head>
<title></title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<%
Behind.WriteHtmlHead
Server.ScriptTimeOut=999999
%>
<body style="background-color: #DBDBDB">
<table width="100%" height="100%" border=0 cellspacing=0 cellpadding=0>
<tr>
<td width="163"> </td>
<td valign=top height=40>
<%
IF Not Response.IsClientConnected Then
Response.Write("对不起，连接失效，请稍候再试！")
Response.End()
End IF
Dim TempPath,FilePath
TempPath = CreatePath()
FilePath = Config.ImagePath
For i = 0 To Ubound(FilePath)
If Right(FilePath(i),1)<>"/" then FilePath(i) = FilePath(i)&"/"
FilePath(i) = FilePath(i)&TempPath
Next
Dim objImage
Set objImage = New Lyout_Image
Dim uploader
Set uploader = New UploadClass
uploader.FileType = Config.UploadExt
uploader.SavePath = FilePath(0)
uploader.MaxSize = Config.Settings(4)*1024
uploader.Open()
Dim PhotoCount,ManuName
PhotoCount = CInt(uploader.Form("PhotoCount"))
ManuName = Trim(uploader.form("ManuName"))
Dim IsMaitu
IsMaitu = uploader.Form("IsMaitu")
Dim UploadCount
UploadCount = 0
Dim strMessage
strMessage = ""
Dim intTemp
Dim strFormName ' 表单名称
Dim strLocalFile ' 本地路径
Dim strDiskPath ' 本地路径用于保存
Dim strFilePath ' 保存路径
Dim strFileName ' 保存文件名
Dim strFileExt
Dim arrFileName
Dim strImageSize
Dim arrImageWide
Dim i,j,intRowIndex
Dim arrImageInfo(11)
Dim arrExifInfo(12)
Dim intImagePoint
For intTemp = 1 To Ubound(uploader.FileItem)
strFormName = uploader.FileItem(intTemp)
If uploader.Form(strFormName&"_Err")<>"-1" Then
strLocalFile = uploader.Form(strFormName&"_Path") & uploader.Form(strFormName&"_Name")
strDiskPath = Replace(strLocalFile,"\","/")
strFileName = uploader.Form(strFormName)
If strFileName<>"" Then
strFileExt = LCase(uploader.form(strFormName&"_Ext"))
arrFileName = FilePath
arrFileName(0) = arrFileName(0)&strFileName
For i = 1 To 2
arrFileName(i) = arrFileName(i)&Replace(strFileName,"."&strFileExt,".jpg")
Next
' 进行水印操作
If Config.WaterMark(0) = "1" Then
objImage.Open arrFileName(0)
If objImage.FileIsOpen Then
With objImage
strImageSize = .Width&","&.Height
arrImageWide = Split(strImageSize,",")
' 大小限制
If CLng(arrImageWide(0)) > CLng(Config.Settings(3)) Or CLng(arrImageWide(1))>CLng(Config.Settings(3)) Then
strImageSize = ","
Else
' 生成小图
.ResizeTo CInt(Config.Settings(5)),CInt(Config.Settings(6))
.SaveAs arrFileName(2)
.Close
' 生成中图
.Open arrFileName(0)
.ResizeTo CInt(Config.Settings(28)),CInt(Config.Settings(29))
' 给中图打水印
If IsMaitu = "1" Then
.DrawCanvas Config.SiteJpeg,ManuName
Else
If Config.WaterMark(1) = "1" Then
If Config.WaterMark(2) = "2" Then
.DrawCanvas Config.SiteJpeg,ManuName
Else
.JpegWidth = CInt(Config.WaterMark(4))
.JpegHeight = CInt(Config.WaterMark(5))
.JpegColor = Hex2Ten(Mid(Config.WaterMark(3),2))
If Config.WaterMark(2) = "0" Then
IF Config.WaterMark(7)<>"" Then
.JpegFamily = Config.WaterMark(9)
.JpegBold = Config.WaterMark(11)
.JpegSize = CInt(Config.WaterMark(10))
.DrawText CInt(Config.WaterMark(6)),Config.WaterMark(7)
End If
Else
.JpegOpacity = Config.WaterMark(12)
.DrawImage CInt(Config.WaterMark(6)),Config.WaterMark(8)
End If
End If
End If
End If
.SaveAs arrFileName(1)
End If
End With
Else
strImageSize = ","
End If
objImage.Close
Else
' 没有安装水印组件时取图片宽高
strImageSize = uploader.form(strFormName&"_Width")&","&uploader.form(strFormName&"_Height")
End If
If strImageSize<>"," then
UploadCount = UploadCount + 1
If Config.WaterMark(0) = "1" And Config.Settings(0) = "0" Then
Netout.DelFile(arrFileName(0))
End If
intRowIndex = Replace(strFormName,"ImageInfo0_","")
If Not Purchase Is Nothing Then
intImagePoint = Purchase.GetUpload(uploader,intRowIndex)
End If
' 取图片关键字和Exif信息
For i = 0 To 11
arrImageInfo(i) = uploader.Form("ImageInfo"&i&"_"&intRowIndex)
arrExifInfo(i) = Replace(Server.HTMLEncode(uploader.Form("ExifInfo"&i&"_"&intRowIndex)&""),"'","'")
Next
arrExifInfo(12) = uploader.Form("ExifInfo12_"&intRowIndex)
arrImageInfo(1) = Netout.HtmlCode(arrImageInfo(1),True)
arrImageInfo(8) = Netout.HtmlEncode(arrImageInfo(8),True)
arrImageInfo(10) = Netout.HtmlEncode(arrImageInfo(10),True)
arrImageInfo(11) = Netout.HtmlEncode(arrImageInfo(11),True)
strFilePath = Replace(arrFileName(0),Config.ImagePath(0),"")
If Left(strFilePath,1)="/" Then strFilePath = Mid(strFilePath,2)
Response.Write "<script language=javascript>parent.form1.UploadFiles.value+='@#@#"&strFilePath&"$#@$"&strDiskPath&"$#@$"&strFileExt&"$#@$"&strImageSize&"$#@$"&intImagePoint&"$#@$"&Join(arrImageInfo,"$||$")&"$#@$"&Join(arrExifInfo,",")&"';</script>"
Else
strMessage = "图片 "&uploader.form(strFormName&"_Name")&" 不符合规格；<br>"
For i = 0 To 2
Netout.DelFile(arrFileName(m))
Next
End If
End If
End If
Next
Set objImage = Nothing
Response.Write(strMessage&UploadCount&"幅作品上传成功，")
If UploadCount>0 Then
Response.Write "请点击“确定”按钮以保存保存数据。<script language=javascript>parent.document.form1.btnSave.disabled=false;</script>"
Else
Response.Write "请 <a href='Admin_Upload_"&IsMaitu&".asp?UploadCount="&UploadCount&"'>返回</a> 重新上传。"
End If
Set uploader = Nothing
Set Netout = Nothing
'按月份自动明名上传文件夹,需要ＦＳＯ组件支持。
Private Function CreatePath()
Dim objFSO,uploaderPath,TempPath,m
MyMonth = Month(Now())
MyDay = Day(Now())
IF Len(MyMonth) = 1 Then MyMonth = "0"&MyMonth
IF Len(MyDay) = 1 Then MyDay = "0"&MyDay
uploaderPath=year(now)&"-"&MyMonth '以年月创建上传文件夹，格式：2003－8
TempPath = Array(Server.MapPath(Config.ImagePath(0)&uploaderPath&"/"&MyDay),_
Server.MapPath(Config.ImagePath(0)&uploaderPath),_
Server.MapPath(Config.ImagePath(1)&uploaderPath&"/"&MyDay),_
Server.MapPath(Config.ImagePath(1)&uploaderPath),_
Server.MapPath(Config.ImagePath(2)&uploaderPath&"/"&MyDay),_
Server.MapPath(Config.ImagePath(2)&uploaderPath))
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
With objFSO
For m = 0 To Ubound(TempPath) Step 2
If Not .FolderExists(TempPath(m)) Then
If Not .FolderExists(TempPath(m+1)) Then
.CreateFolder TempPath(m+1)
End If
.CreateFolder TempPath(m)
End If
Next
End With
If Err.Number = 0 Then
CreatePath=uploaderPath&"/"&MyDay&"/"
Else
CreatePath=""
End If
Set objFSO = nothing
End Function
Function Hex2Ten(strings)
Dim i,tmp,iLen,num
num = 0:iLen = Len(strings)
For i = 1 To Len(strings)
tmp = Mid(strings,i,1)
If IsNumeric(tmp) Then
tmp = tmp * 16^(iLen-i)
Else
tmp= (ASC(UCase(tmp))-55) * 16^(iLen-i)
End If
num = num + tmp
Next
Hex2Ten = num
End Function
%>
</td></tr>
</table>
</body>
</html>